home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / dump.c < prev    next >
C/C++ Source or Header  |  1998-07-19  |  10KB  |  423 lines
  1. /*    dump.c
  2.  *
  3.  *    Copyright (c) 1991-1997, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * "'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and
  12.  * it has not been hard for me to read your mind and memory.'"
  13.  */
  14.  
  15. #include "EXTERN.h"
  16. #include "perl.h"
  17.  
  18. #ifndef PERL_OBJECT
  19. static void dump(char *pat, ...);
  20. #endif /* PERL_OBJECT */
  21.  
  22. void
  23. dump_all(void)
  24. {
  25. #ifdef DEBUGGING
  26.     dTHR;
  27.     PerlIO_setlinebuf(Perl_debug_log);
  28.     if (PL_main_root)
  29.     dump_op(PL_main_root);
  30.     dump_packsubs(PL_defstash);
  31. #endif    /* DEBUGGING */
  32. }
  33.  
  34. void
  35. dump_packsubs(HV *stash)
  36. {
  37. #ifdef DEBUGGING
  38.     dTHR;
  39.     I32    i;
  40.     HE    *entry;
  41.  
  42.     if (!HvARRAY(stash))
  43.     return;
  44.     for (i = 0; i <= (I32) HvMAX(stash); i++) {
  45.     for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
  46.         GV *gv = (GV*)HeVAL(entry);
  47.         HV *hv;
  48.         if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv))
  49.         continue;
  50.         if (GvCVu(gv))
  51.         dump_sub(gv);
  52.         if (GvFORM(gv))
  53.         dump_form(gv);
  54.         if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
  55.           (hv = GvHV(gv)) && HvNAME(hv) && hv != PL_defstash)
  56.         dump_packsubs(hv);        /* nested package */
  57.     }
  58.     }
  59. #endif    /* DEBUGGING */
  60. }
  61.  
  62. void
  63. dump_sub(GV *gv)
  64. {
  65. #ifdef DEBUGGING
  66.     SV *sv = sv_newmortal();
  67.  
  68.     gv_fullname3(sv, gv, Nullch);
  69.     dump("\nSUB %s = ", SvPVX(sv));
  70.     if (CvXSUB(GvCV(gv)))
  71.     dump("(xsub 0x%x %d)\n",
  72.         (long)CvXSUB(GvCV(gv)),
  73.         CvXSUBANY(GvCV(gv)).any_i32);
  74.     else if (CvROOT(GvCV(gv)))
  75.     dump_op(CvROOT(GvCV(gv)));
  76.     else
  77.     dump("<undef>\n");
  78. #endif    /* DEBUGGING */
  79. }
  80.  
  81. void
  82. dump_form(GV *gv)
  83. {
  84. #ifdef DEBUGGING
  85.     SV *sv = sv_newmortal();
  86.  
  87.     gv_fullname3(sv, gv, Nullch);
  88.     dump("\nFORMAT %s = ", SvPVX(sv));
  89.     if (CvROOT(GvFORM(gv)))
  90.     dump_op(CvROOT(GvFORM(gv)));
  91.     else
  92.     dump("<undef>\n");
  93. #endif    /* DEBUGGING */
  94. }
  95.  
  96. void
  97. dump_eval(void)
  98. {
  99. #ifdef DEBUGGING
  100.     dump_op(PL_eval_root);
  101. #endif    /* DEBUGGING */
  102. }
  103.  
  104. void
  105. dump_op(OP *o)
  106. {
  107. #ifdef DEBUGGING
  108.     dump("{\n");
  109.     if (o->op_seq)
  110.     PerlIO_printf(Perl_debug_log, "%-4d", o->op_seq);
  111.     else
  112.     PerlIO_printf(Perl_debug_log, "    ");
  113.     dump("TYPE = %s  ===> ", op_name[o->op_type]);
  114.     if (o->op_next) {
  115.     if (o->op_seq)
  116.         PerlIO_printf(Perl_debug_log, "%d\n", o->op_next->op_seq);
  117.     else
  118.         PerlIO_printf(Perl_debug_log, "(%d)\n", o->op_next->op_seq);
  119.     }
  120.     else
  121.     PerlIO_printf(Perl_debug_log, "DONE\n");
  122.     PL_dumplvl++;
  123.     if (o->op_targ) {
  124.     if (o->op_type == OP_NULL)
  125.         dump("  (was %s)\n", op_name[o->op_targ]);
  126.     else
  127.         dump("TARG = %d\n", o->op_targ);
  128.     }
  129. #ifdef DUMPADDR
  130.     dump("ADDR = 0x%lx => 0x%lx\n",o, o->op_next);
  131. #endif
  132.     if (o->op_flags) {
  133.     SV *tmpsv = newSVpv("", 0);
  134.     switch (o->op_flags & OPf_WANT) {
  135.     case OPf_WANT_VOID:
  136.         sv_catpv(tmpsv, ",VOID");
  137.         break;
  138.     case OPf_WANT_SCALAR:
  139.         sv_catpv(tmpsv, ",SCALAR");
  140.         break;
  141.     case OPf_WANT_LIST:
  142.         sv_catpv(tmpsv, ",LIST");
  143.         break;
  144.     default:
  145.         sv_catpv(tmpsv, ",UNKNOWN");
  146.         break;
  147.     }
  148.     if (o->op_flags & OPf_KIDS)
  149.         sv_catpv(tmpsv, ",KIDS");
  150.     if (o->op_flags & OPf_PARENS)
  151.         sv_catpv(tmpsv, ",PARENS");
  152.     if (o->op_flags & OPf_STACKED)
  153.         sv_catpv(tmpsv, ",STACKED");
  154.     if (o->op_flags & OPf_REF)
  155.         sv_catpv(tmpsv, ",REF");
  156.     if (o->op_flags & OPf_MOD)
  157.         sv_catpv(tmpsv, ",MOD");
  158.     if (o->op_flags & OPf_SPECIAL)
  159.         sv_catpv(tmpsv, ",SPECIAL");
  160.     dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
  161.     SvREFCNT_dec(tmpsv);
  162.     }
  163.     if (o->op_private) {
  164.     SV *tmpsv = newSVpv("", 0);
  165.     if (o->op_type == OP_AASSIGN) {
  166.         if (o->op_private & OPpASSIGN_COMMON)
  167.         sv_catpv(tmpsv, ",COMMON");
  168.     }
  169.     else if (o->op_type == OP_SASSIGN) {
  170.         if (o->op_private & OPpASSIGN_BACKWARDS)
  171.         sv_catpv(tmpsv, ",BACKWARDS");
  172.     }
  173.     else if (o->op_type == OP_TRANS) {
  174.         if (o->op_private & OPpTRANS_SQUASH)
  175.         sv_catpv(tmpsv, ",SQUASH");
  176.         if (o->op_private & OPpTRANS_DELETE)
  177.         sv_catpv(tmpsv, ",DELETE");
  178.         if (o->op_private & OPpTRANS_COMPLEMENT)
  179.         sv_catpv(tmpsv, ",COMPLEMENT");
  180.     }
  181.     else if (o->op_type == OP_REPEAT) {
  182.         if (o->op_private & OPpREPEAT_DOLIST)
  183.         sv_catpv(tmpsv, ",DOLIST");
  184.     }
  185.     else if (o->op_type == OP_ENTERSUB ||
  186.          o->op_type == OP_RV2SV ||
  187.          o->op_type == OP_RV2AV ||
  188.          o->op_type == OP_RV2HV ||
  189.          o->op_type == OP_RV2GV ||
  190.          o->op_type == OP_AELEM ||
  191.          o->op_type == OP_HELEM )
  192.     {
  193.         if (o->op_type == OP_ENTERSUB) {
  194.         if (o->op_private & OPpENTERSUB_AMPER)
  195.             sv_catpv(tmpsv, ",AMPER");
  196.         if (o->op_private & OPpENTERSUB_DB)
  197.             sv_catpv(tmpsv, ",DB");
  198.         }
  199.         switch (o->op_private & OPpDEREF) {
  200.         case OPpDEREF_SV:
  201.         sv_catpv(tmpsv, ",SV");
  202.         break;
  203.         case OPpDEREF_AV:
  204.         sv_catpv(tmpsv, ",AV");
  205.         break;
  206.         case OPpDEREF_HV:
  207.         sv_catpv(tmpsv, ",HV");
  208.         break;
  209.         }
  210.         if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) {
  211.         if (o->op_private & OPpLVAL_DEFER)
  212.             sv_catpv(tmpsv, ",LVAL_DEFER");
  213.         }
  214.         else {
  215.         if (o->op_private & HINT_STRICT_REFS)
  216.             sv_catpv(tmpsv, ",STRICT_REFS");
  217.         }
  218.     }
  219.     else if (o->op_type == OP_CONST) {
  220.         if (o->op_private & OPpCONST_BARE)
  221.         sv_catpv(tmpsv, ",BARE");
  222.     }
  223.     else if (o->op_type == OP_FLIP) {
  224.         if (o->op_private & OPpFLIP_LINENUM)
  225.         sv_catpv(tmpsv, ",LINENUM");
  226.     }
  227.     else if (o->op_type == OP_FLOP) {
  228.         if (o->op_private & OPpFLIP_LINENUM)
  229.         sv_catpv(tmpsv, ",LINENUM");
  230.     }
  231.     if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
  232.         sv_catpv(tmpsv, ",INTRO");
  233.     if (SvCUR(tmpsv))
  234.         dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
  235.     SvREFCNT_dec(tmpsv);
  236.     }
  237.  
  238.     switch (o->op_type) {
  239.     case OP_GVSV:
  240.     case OP_GV:
  241.     if (cGVOPo->op_gv) {
  242.         SV *tmpsv = NEWSV(0,0);
  243.         ENTER;
  244.         SAVEFREESV(tmpsv);
  245.         gv_fullname3(tmpsv, cGVOPo->op_gv, Nullch);
  246.         dump("GV = %s\n", SvPV(tmpsv, PL_na));
  247.         LEAVE;
  248.     }
  249.     else
  250.         dump("GV = NULL\n");
  251.     break;
  252.     case OP_CONST:
  253.     dump("SV = %s\n", SvPEEK(cSVOPo->op_sv));
  254.     break;
  255.     case OP_NEXTSTATE:
  256.     case OP_DBSTATE:
  257.     if (cCOPo->cop_line)
  258.         dump("LINE = %d\n",cCOPo->cop_line);
  259.     if (cCOPo->cop_label)
  260.         dump("LABEL = \"%s\"\n",cCOPo->cop_label);
  261.     break;
  262.     case OP_ENTERLOOP:
  263.     dump("REDO ===> ");
  264.     if (cLOOPo->op_redoop)
  265.         PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_redoop->op_seq);
  266.     else
  267.         PerlIO_printf(Perl_debug_log, "DONE\n");
  268.     dump("NEXT ===> ");
  269.     if (cLOOPo->op_nextop)
  270.         PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_nextop->op_seq);
  271.     else
  272.         PerlIO_printf(Perl_debug_log, "DONE\n");
  273.     dump("LAST ===> ");
  274.     if (cLOOPo->op_lastop)
  275.         PerlIO_printf(Perl_debug_log, "%d\n", cLOOPo->op_lastop->op_seq);
  276.     else
  277.         PerlIO_printf(Perl_debug_log, "DONE\n");
  278.     break;
  279.     case OP_COND_EXPR:
  280.     dump("TRUE ===> ");
  281.     if (cCONDOPo->op_true)
  282.         PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_true->op_seq);
  283.     else
  284.         PerlIO_printf(Perl_debug_log, "DONE\n");
  285.     dump("FALSE ===> ");
  286.     if (cCONDOPo->op_false)
  287.         PerlIO_printf(Perl_debug_log, "%d\n", cCONDOPo->op_false->op_seq);
  288.     else
  289.         PerlIO_printf(Perl_debug_log, "DONE\n");
  290.     break;
  291.     case OP_MAPWHILE:
  292.     case OP_GREPWHILE:
  293.     case OP_OR:
  294.     case OP_AND:
  295.     dump("OTHER ===> ");
  296.     if (cLOGOPo->op_other)
  297.         PerlIO_printf(Perl_debug_log, "%d\n", cLOGOPo->op_other->op_seq);
  298.     else
  299.         PerlIO_printf(Perl_debug_log, "DONE\n");
  300.     break;
  301.     case OP_PUSHRE:
  302.     case OP_MATCH:
  303.     case OP_QR:
  304.     case OP_SUBST:
  305.     dump_pm(cPMOPo);
  306.     break;
  307.     default:
  308.     break;
  309.     }
  310.     if (o->op_flags & OPf_KIDS) {
  311.     OP *kid;
  312.     for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
  313.         dump_op(kid);
  314.     }
  315.     PL_dumplvl--;
  316.     dump("}\n");
  317. #endif    /* DEBUGGING */
  318. }
  319.  
  320. void
  321. dump_gv(GV *gv)
  322. {
  323. #ifdef DEBUGGING
  324.     SV *sv;
  325.  
  326.     if (!gv) {
  327.     PerlIO_printf(Perl_debug_log, "{}\n");
  328.     return;
  329.     }
  330.     sv = sv_newmortal();
  331.     PL_dumplvl++;
  332.     PerlIO_printf(Perl_debug_log, "{\n");
  333.     gv_fullname3(sv, gv, Nullch);
  334.     dump("GV_NAME = %s", SvPVX(sv));
  335.     if (gv != GvEGV(gv)) {
  336.     gv_efullname3(sv, GvEGV(gv), Nullch);
  337.     dump("-> %s", SvPVX(sv));
  338.     }
  339.     dump("\n");
  340.     PL_dumplvl--;
  341.     dump("}\n");
  342. #endif    /* DEBUGGING */
  343. }
  344.  
  345. void
  346. dump_pm(PMOP *pm)
  347. {
  348. #ifdef DEBUGGING
  349.     char ch;
  350.  
  351.     if (!pm) {
  352.     dump("{}\n");
  353.     return;
  354.     }
  355.     dump("{\n");
  356.     PL_dumplvl++;
  357.     if (pm->op_pmflags & PMf_ONCE)
  358.     ch = '?';
  359.     else
  360.     ch = '/';
  361.     if (pm->op_pmregexp)
  362.     dump("PMf_PRE %c%s%c%s\n",
  363.          ch, pm->op_pmregexp->precomp, ch,
  364.          (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : "");
  365.     else
  366.     dump("PMf_PRE (RUNTIME)\n");
  367.     if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) {
  368.     dump("PMf_REPL = ");
  369.     dump_op(pm->op_pmreplroot);
  370.     }
  371.     if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
  372.     SV *tmpsv = newSVpv("", 0);
  373.     if (pm->op_pmdynflags & PMdf_USED)
  374.         sv_catpv(tmpsv, ",USED");
  375.     if (pm->op_pmdynflags & PMdf_TAINTED)
  376.         sv_catpv(tmpsv, ",TAINTED");
  377.     if (pm->op_pmflags & PMf_ONCE)
  378.         sv_catpv(tmpsv, ",ONCE");
  379.     if (pm->op_pmregexp && pm->op_pmregexp->check_substr
  380.         && !(pm->op_pmregexp->reganch & ROPT_NOSCAN))
  381.         sv_catpv(tmpsv, ",SCANFIRST");
  382.     if (pm->op_pmregexp && pm->op_pmregexp->check_substr
  383.         && pm->op_pmregexp->reganch & ROPT_CHECK_ALL)
  384.         sv_catpv(tmpsv, ",ALL");
  385.     if (pm->op_pmflags & PMf_SKIPWHITE)
  386.         sv_catpv(tmpsv, ",SKIPWHITE");
  387.     if (pm->op_pmflags & PMf_CONST)
  388.         sv_catpv(tmpsv, ",CONST");
  389.     if (pm->op_pmflags & PMf_KEEP)
  390.         sv_catpv(tmpsv, ",KEEP");
  391.     if (pm->op_pmflags & PMf_GLOBAL)
  392.         sv_catpv(tmpsv, ",GLOBAL");
  393.     if (pm->op_pmflags & PMf_CONTINUE)
  394.         sv_catpv(tmpsv, ",CONTINUE");
  395.     if (pm->op_pmflags & PMf_RETAINT)
  396.         sv_catpv(tmpsv, ",RETAINT");
  397.     if (pm->op_pmflags & PMf_EVAL)
  398.         sv_catpv(tmpsv, ",EVAL");
  399.     dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
  400.     SvREFCNT_dec(tmpsv);
  401.     }
  402.  
  403.     PL_dumplvl--;
  404.     dump("}\n");
  405. #endif    /* DEBUGGING */
  406. }
  407.  
  408.  
  409. STATIC void
  410. dump(char *pat,...)
  411. {
  412. #ifdef DEBUGGING
  413.     I32 i;
  414.     va_list args;
  415.  
  416.     va_start(args, pat);
  417.     for (i = PL_dumplvl*4; i; i--)
  418.     (void)PerlIO_putc(Perl_debug_log,' ');
  419.     PerlIO_vprintf(Perl_debug_log,pat,args);
  420.     va_end(args);
  421. #endif    /* DEBUGGING */
  422. }
  423.